{-# LANGUAGE MultiParamTypeClasses, OverlappingInstances, FlexibleInstances, FunctionalDependencies, UndecidableInstances #-}

module LLVM.Util where

-----------------------------------------------------------------------------
-- |
-- Module      : LLVM.Util
-- Copyright   : Mikhail Belyaev
-- License     : GPLv3 (see LICENSE)
-- Portability : Non-portable (see header)
--
-- All useful junk intended for reuse
-----------------------------------------------------------------------------

import Control.Monad
import Control.Monad.State
import Control.Monad.Error

import Debug.Trace
import Data.Maybe (catMaybes)
import Data.List (genericLength, genericIndex)
import Data.Char (chr)
import Data.Bits (Bits(..), complement)

debug = flip trace
mdebug mes = skipm `debug` mes
idebug a = a `debug` show a

infixl 9 .$
infixl 9 .?
infixr 4 ??
infixl 4 ?!
infixl 9 ?

(??) :: Maybe a -> a -> a
Nothing ?? x = x
Just v ?? _ = v

(?) :: (a -> b) -> Maybe a -> Maybe b
f ? Nothing = Nothing
f ? Just v = Just $ f v

(?!) :: (a -> b) -> Maybe a -> b
f ?! Nothing = error "?!: Maybe arg is Nothing"
f ?! Just v = f v


(.$) :: a -> (a -> b) -> b
a .$ f = f a

(.?) :: Maybe a -> (a -> b) -> Maybe b
(.?) = flip (?)

-- loop call to monad @n@ times
loop :: Monad m => m a -> Int -> m [a]
loop f n = replicateM n f

-- call monad while monadic condition is reached
-- better off using no state-changing monad with Bool
-- otherwise make note it's called every time before f
while :: Monad m => m a -> m Bool -> m[a]
while f p =
        do cond <- p
           if(cond)
              then do v <- f
                      rest <- f `while` p
                      return (v : rest)
              else return []

-- just combining two monads and their results
-- they are called in order
andThen :: Monad m => m a -> m b -> m (a,b)
andThen x y =
        do
           x' <- x
           y' <- y
           return (x',y')


-- `not' lifted to monadic function monad -> monad
notm :: Monad m => m Bool -> m Bool
notm = liftM not

-- dump result of monadic computation after calling it
ignorem :: Monad m => m a -> m ()
ignorem = liftM $ const ()

skipm :: Monad m => m ()
skipm = return ()

doNothing :: Monad m => m ()
doNothing = skipm

-- just a sinonym for Either String a
-- Control.Monad.Error.Class provides it's
-- an instance of Monad, so it's a full-blown monad and all
type MayError a = Either String a

-- use the outmost error if any
joinMe :: MayError (MayError a) -> MayError a
joinMe (Right (Right v)) = Right v
joinMe (Left mes) = Left mes
joinMe (Right (Left mes)) = Left mes

-- just a convenient func equal to Right
meSucceed :: a -> MayError a
meSucceed = Right

-- just a convenient func equal to Left
meFail :: String -> MayError a
meFail = Left

-- test for rightness
meSucceeded :: MayError a -> Bool
meSucceeded (Right _) = True
meSucceeded (Left _) = False

-- test for wrongness
meFailed :: MayError a -> Bool
meFailed = not . meSucceeded

-- a bridge between Maybe-based errors and MayError
-- just puts a message along if it's needed
maybe2mayerror :: (Error e) => Maybe a -> e -> Either e a
maybe2mayerror (Just v) _ = Right v
maybe2mayerror (Nothing) message = Left message

-- a bridge between MayError and Maybe-based errors
-- throw away the error message
ignoreMeError :: MayError a -> Maybe a
ignoreMeError (Right v) = Just v
ignoreMeError (Left _) = Nothing

-- a bridge between MayError and Maybe-based errors
-- upside-down gap that throws away the result
-- and preserves the error message
ignoreMeValue :: MayError a -> Maybe String
ignoreMeValue (Right _) = Nothing
ignoreMeValue (Left mes) = Just mes

-- a bridge between MayError and Maybe-based errors
-- equal to (ignoreMeError x,ignoreMeValue x)
mayerror2maybe :: MayError a -> (Maybe a, Maybe String)
mayerror2maybe (Right v) = (Just v, Nothing)
mayerror2maybe (Left mes) = (Nothing, Just mes)

-- a sinonym for string-based error handling monads
type ErrorOf m = ErrorT String m

-- extract the error (if any) and lift the monad down the stack
-- one floor
unliftError :: (Monad m) => ErrorOf m a -> m (MayError a)
unliftError = runErrorT

-- lift the base monad one floor up to error variant
-- cannot produce errors (hence the name failsafe), of course
failsafe :: (Monad m) => m a -> ErrorOf m a
failsafe = lift

-- extract the error (if any) and stay right here
-- guarantees that no error is present if validator is used
-- universal version, use it
-- equal to @uncoverError'@, which is not recommended
uncoverError :: (MonadError e m, Error e) => m a -> m (Either e a)
uncoverError input = let handler e = return $ Left e in
                 liftM Right input `catchError` handler

-- Promote a non-monadic error to exception-like error-monad-based error
-- can be used in following safety-granted-pattern:
-- do
--    xr <- uncoverError x -- capture the error and keep it
--    <.. some error-safe stuff ..>
--    xr' <- promoteError xr -- return the error to monad if any
--    <.. continue ..>
-- This includes type (Monad m => MayError a -> ErrorOf m a)
promoteError :: MonadError e m => Either e a -> m a
promoteError (Left mes) = throwError mes
promoteError (Right val) = return val

promoteMaybe :: (MonadError e m, Error e) => Maybe a -> e -> m a
promoteMaybe mb mes = promoteError $ maybe2mayerror mb mes

-- Promote a monadic either-based error to exception
-- can be viewed as opposite to @uncoverError@:
-- uncoverError $ coverError x usually equals to x
-- coverError $ uncoverError x usually equals to x
coverError :: MonadError e m => m (Either e a) -> m a
coverError i = do
                er <- i
                ret <- promoteError er
                return ret

-- Throw error from one error-based monad to another
-- usually used to gather errors between several monads in stack
throwTo :: (Error e, MonadError e m0, MonadError e m1) =>
        (m0 (Either e a) -> m1 (Either e a)) -> m0 a -> m1 a
throwTo f = coverError . f . uncoverError

-- | @FarSeer@ class provides funcs
-- @deepGet@ (getting all states in monad stack) - to be overriden
-- @deepPut@ (putting all states in monad stack) - to be overriden
-- @deepGets@ deepGet with function (equal to gets)
-- @lookAhead@ make a computation without affecting any states
class (Monad m) => FarSeer s m | m -> s where
    deepGet :: m s
    deepPut :: s -> m ()
    deepGets :: (s -> a) -> m a
    deepGets f = liftM f $ deepGet
    -- | Run @act@, but return without consuming its input.
    -- Fails if @act@ fails.
    lookAhead :: m a -> m a
    lookAhead act = do
                       st <- deepGet
                       res <- act
                       deepPut st
                       return res

-- the next approach is using three overlapping instances to make it polymorphic
-- for example a monad like ErrorT String StateT Integet StateT Int State Integer
-- will call versions like f3 -> f2 -> f2 -> f1 saving states in tuple (s2,(s1,s0))
-- not portable though :-(

-- For a simple state monad it's rather straightforward
instance (MonadState s m) => FarSeer s m where
        deepGet = get
        deepPut = put

-- For a state transformer it involves some downing recursion and tuples of states
instance (FarSeer s0 m) => FarSeer (s,s0) (StateT s m) where
        deepGet = do
                     st0 <- lift deepGet
                     st <- get
                     return (st,st0)
        deepPut (st,st0) = do
                                put st
                                lift $ deepPut st0
                                return ()

-- For any other transformer, it's better to ask state monads to handle their states for them
instance (FarSeer s m, MonadTrans tr, Monad (tr m)) => FarSeer s (tr m) where
        deepGet = do
                     st <- lift deepGet
                     return st
        deepPut st = do
                       lift $ deepPut st
                       return ()

maybeFilter :: (a -> Maybe b) -> [a] -> [b]
maybeFilter f as = catMaybes $ map f as

(?*) :: (a -> Maybe b) -> [a] -> [b]
(?*) = maybeFilter

class (Enum a, Bounded a) => BoundedEnum a where
    enumSet :: [a]
    enumSet = [minBound .. maxBound]
    beFromInt :: (Integral b) => b -> a
    beFromInt i = enumSet `genericIndex` i
    beToInt :: (Integral b) => a -> b
    beToInt be = fromIntegral $ fromEnum be
    beFromIntSafe :: (Integral b) => b -> Maybe a
    beFromIntSafe i | (i >= 0 && i < genericLength set) = Just $ set `genericIndex` i
                    where set = enumSet
    beFromIntSafe _ = Nothing

instance (Enum a, Bounded a) => BoundedEnum a where

flop :: Maybe (Maybe a) -> Maybe a
flop Nothing = Nothing
flop (Just Nothing) = Nothing
flop (Just (Just x)) = Just x

snoc :: [a] -> a -> [a]
snoc xs x = xs ++ [x]

pairs :: [a] -> [(a,a)]
pairs []      = []
pairs (a:[])  = []
pairs (a:b:c) = (a,b):pairs c

tzip :: ([a],[b]) -> [(a,b)]
tzip smth = zip (fst smth) (snd smth)

--
--tst2 :: StateT Integer (ErrorT String (StateT Integer (State Integer))) (Integer,(Integer,Integer))
--tst2 = do
--        put 1
--        lift $ lift $ put 2
--        lift $ lift $ lift $ put 3
--        lookAhead $ lift $ lift $ lift $ put 665
--        lookAhead $ lift $ lift $ put 123
--        lookAhead $ put 19
--        uncoverError $ lookAhead $ throwError "Whoa!!!"
--        stt <- deepGet
--        return stt
--
--try = let outer1 = evalStateT tst2 0
--          outer2 = runErrorT outer1
--          outer3 = evalStateT outer2 0
--          outer4 = evalState outer3 0
--      in
--      outer4


massOrd :: [Integer] -> String
massOrd = map (chr . fromInteger)

tosigned :: Integer -> Integer
tosigned i | testBit i 0 == False = i `shiftR` 1
tosigned i | i /= 1 = -(i `shiftR` 1)
-- (-0) case.
tosigned 1 = complement 0 --0xFFFFFFFF --TODO : change to smth more informative (really is MININT)


mayhead :: [a] -> Maybe a
mayhead [] = Nothing
mayhead (x:_) = Just x

class Replica a c | c -> a where
    mmatch :: a -> c
instance Replica a (a,a) where
    mmatch a =     (a,a)
instance Replica a (a,a,a) where
    mmatch a =     (a,a,a)
instance Replica a (a,a,a,a) where
    mmatch a =     (a,a,a,a)
instance Replica a (a,a,a,a,a) where
    mmatch a =     (a,a,a,a,a)
instance Replica a (a,a,a,a,a,a) where
    mmatch a =     (a,a,a,a,a,a)
instance Replica a (a,a,a,a,a,a,a) where
    mmatch a =     (a,a,a,a,a,a,a)
instance Replica a (a,a,a,a,a,a,a,a) where
    mmatch a =     (a,a,a,a,a,a,a,a)
instance Replica a (a,a,a,a,a,a,a,a,a) where
    mmatch a =     (a,a,a,a,a,a,a,a,a)
instance Replica a (a,a,a,a,a,a,a,a,a,a) where
    mmatch a =     (a,a,a,a,a,a,a,a,a,a)
instance Replica a (a,a,a,a,a,a,a,a,a,a,a) where
    mmatch a =     (a,a,a,a,a,a,a,a,a,a,a)
instance Replica a (a,a,a,a,a,a,a,a,a,a,a,a) where
    mmatch a =     (a,a,a,a,a,a,a,a,a,a,a,a)
instance Replica a (a,a,a,a,a,a,a,a,a,a,a,a,a) where
    mmatch a =     (a,a,a,a,a,a,a,a,a,a,a,a,a)
instance Replica a (a,a,a,a,a,a,a,a,a,a,a,a,a,a) where
    mmatch a =     (a,a,a,a,a,a,a,a,a,a,a,a,a,a)
instance Replica a (a,a,a,a,a,a,a,a,a,a,a,a,a,a,a) where
    mmatch a =     (a,a,a,a,a,a,a,a,a,a,a,a,a,a,a)
instance Replica a [a] where
    mmatch a = a : mmatch a

class Constable f v where
    deepconst :: v -> f

instance Constable r r where
    deepconst = id

instance Constable (a -> r) r where
    deepconst c _ = deepconst c

instance Constable (a -> b -> r) r where
    deepconst c _ = deepconst c

instance Constable (a -> b -> c -> r) r where
    deepconst c _ = deepconst c

instance Constable (a -> b -> c -> d -> r) r where
    deepconst c _ = deepconst c

instance Constable (a -> b -> c -> d -> e -> r) r where
    deepconst c _ = deepconst c

instance Constable (a -> b -> c -> d -> e -> f -> r) r where
    deepconst c _ = deepconst c


class IntegerPartiallyCompatible a where
    icToInteger :: (Integral b) => a -> b
    integerToIC :: (Integral b) => b -> Maybe a

instance (Integral a) => IntegerPartiallyCompatible a where
    icToInteger = fromIntegral
    integerToIC = Just . fromIntegral